home *** CD-ROM | disk | FTP | other *** search
/ The 640 MEG Shareware Studio 2 / The 640 Meg Shareware Studio CD-ROM Volume II (Data Express)(1993).ISO / pascal / inline22.zip / UNPARS.INC < prev   
Text File  |  1987-09-27  |  7KB  |  318 lines
  1.                        {UnPars.inc}
  2. (*********  Source code Copyright 1986, by L. David Baldwin   *********)
  3.  
  4. Type
  5.   Symb = (Nul,Ident4,Ident2,Identunk,Bytesy,Wordsy,Lparn,Rparn);
  6. Var
  7.   Sy  : Symb;
  8.  
  9. {-------------DefaultExtension}
  10. PROCEDURE DefaultExtension(Extension:Filestring;Var Infile,Name :Filestring);
  11. {Given a filename, infile, add a default extension if none exists. Return
  12.  also the name without any extension.}
  13. Var
  14.  I,J : Integer;
  15.  Temp : Filestring;
  16. begin
  17. I:=Pos('..',Infile);
  18. if I=0 then
  19.   Temp:=Infile
  20. else
  21.   begin   {a pathname starting with ..}
  22.   Temp:=Copy(Infile,I+2,64);
  23.   I:=I+1;
  24.   end;
  25. J:=Pos('.',Temp);
  26. if J=0 then
  27.   begin
  28.   Name := Infile;
  29.   Infile:=Infile+'.'+Extension;
  30.   end
  31. else Name:=Copy(Infile,1,I+J-1);
  32. end;
  33.  
  34. {-------------GetCh}
  35. PROCEDURE GetCh;
  36. {Return next char in Uch and lch with Uch in upper case. Ignore comments}
  37. Var Comment : Boolean;
  38.   PROCEDURE GetchBasic; {read a character and a character pair}
  39.   begin
  40.   if Chi<=Ord(St[0]) then
  41.     begin  {NOTE: pair has the same address as lch}
  42.     Move(St[Chi], Pair, 2);
  43.     if LCh=Chr(Tab) then LCh:=' ';
  44.     UCh := UpCase(LCh);
  45.     Chi := Chi+1;
  46.     end
  47.   else
  48.     if not EOF(Inf) then
  49.       begin
  50.       ReadLn(Inf,St);
  51.       St:=St+' ';  {EOL is equivalent to space}
  52.       Chi:=1;
  53.       GetCh;
  54.       end
  55.     else
  56.       begin
  57.       EofInf:=True;
  58.       if Comment then
  59.         begin
  60.         WriteLn('Open Comment at End of Input File');
  61.         Halt(1);
  62.         end;
  63.       end;
  64.   end;
  65.  
  66. begin  {Getch}
  67. if UCh<>' ' then
  68.   Symname:=Symname+UCh;  {build up a phrase with old character}
  69. repeat
  70.   if EofInf then
  71.     begin WriteLn('Unexpected End of Input File'); Halt(1) end;
  72.   Comment:=False;
  73.   GetchBasic;
  74.   if (UCh='{') or (Pair='(*') then
  75.     begin
  76.     Comment:=True;
  77.     if UCh='{' then repeat GetchBasic; until UCh='}'
  78.     else
  79.       begin
  80.       repeat GetchBasic; until Pair='*)';
  81.       GetchBasic;  {pass by the '*'}
  82.       end;
  83.     end;
  84. until not Comment;
  85. end;
  86.  
  87. {-------------SkipSpaces}
  88. PROCEDURE SkipSpaces;
  89. begin
  90. while (UCh=' ') or (UCh=Chr(Tab)) do
  91.   GetCh;
  92. end;
  93.  
  94. {-------------GetDec}
  95. FUNCTION GetDec(Var V :Integer): Boolean ;
  96. Const
  97.   Ssize = 8;
  98. Var
  99.   S        : String[Ssize];
  100.   Getd     : Boolean;
  101.   Code     : Integer;
  102. begin
  103. Getd := False;
  104. S := '';
  105. while (UCh>='0') and (UCh<='9') do
  106.   begin
  107.   Getd := True;
  108.   if Ord(S[0])<Ssize
  109.     then S := S+UCh;
  110.   GetCh;
  111.   end;
  112. if Getd then
  113.     begin
  114.     Val(S,V,Code);
  115.     if Code<>0
  116.       then Error(Chi,'Bad Number Format');
  117.     end;
  118. GetDec := Getd;
  119. end;
  120.  
  121. {-------------GetHex}
  122. FUNCTION GetHex(Var H :Integer): Boolean;
  123. Var
  124.   Digit   : Integer;     {check for '$' before the call}
  125. begin
  126. H := 0;
  127. GetHex := False;
  128. while (UCh in ['A'..'F','0'..'9']) do
  129.   begin
  130.   GetHex := True;
  131.   if (UCh>='A')
  132.     then Digit := Ord(UCh)-Ord('A')+10
  133.     else Digit := Ord(UCh)-Ord('0');
  134.   if H>=$1000
  135.     then Error(Chi,'Overflow');
  136.   H := (H Shl 4)+Digit;
  137.   GetCh;
  138.   end;
  139. end;
  140.  
  141. {-------------GetNumber}
  142. FUNCTION GetNumber(Var N :Integer): Boolean;
  143. {get a number and return it in n}
  144. begin
  145. SkipSpaces;
  146. N := 0;
  147. if UCh='$'
  148.   then
  149.     begin        {a hex number}
  150.     GetCh;
  151.     if not GetHex(N)
  152.       then Error(Chi, 'Hex Number Exp');
  153.     GetNumber := True;
  154.     end
  155.   else
  156.     begin        {maybe a decimal number}
  157.     GetNumber := GetDec(N);
  158.     end;
  159. end;
  160.  
  161. {-------------GetExpr}
  162. FUNCTION GetExpr(Var Rslt :Integer): Boolean;
  163. Var
  164.   Rs1,Rs2 : Integer;
  165.   Pos,Neg,GE : Boolean;
  166. begin
  167. GE := False;
  168. SkipSpaces;
  169. Neg := UCh='-';
  170. Pos := UCh='+';
  171. if Pos or Neg
  172.   then GetCh;
  173. if GetNumber(Rs1)
  174.   then
  175.     begin
  176.     GE := True;
  177.     if Neg
  178.       then Rs1 := -Rs1;
  179.     SkipSpaces;
  180.     if (UCh='+') or (UCh='-') then
  181.       if GetExpr(Rs2) then
  182.         Rs1 := Rs1+Rs2      {GetExpr will take care of sign}
  183.       else GE:=False;
  184.     Rslt := Rs1;
  185.     end;
  186. SkipSpaces;
  187. GetExpr:=GE and ((UCh='/') or (UCh=')'));  {must terminate in '/' or ')'}
  188. end;
  189.  
  190. {-------------GetToken}
  191. PROCEDURE GetToken;
  192. Const
  193.   Tokenchars : set of Char = ['A'..'Z','0'..'9','_'];
  194.   Startchars : set of Char = ['A'..'Z','_'];
  195. begin
  196. while not (UCh in Startchars) and not EofInf do GetCh;
  197. Token[0] := #0;
  198. if not EofInf then
  199.     while UCh in Tokenchars do
  200.       begin
  201.       if Ord(Token[0])<Tokenleng
  202.         then Token := Token+UCh;
  203.       GetCh;
  204.       end;
  205. end;
  206.  
  207. {-------------Next}
  208. PROCEDURE Next;
  209. Var C : Char;
  210.  
  211.   FUNCTION GetExprX(Var N : Word; Var C : Char): Boolean;
  212.   begin
  213.   C:=UCh;
  214.   if (UCh='>') or (UCh='<') then GetCh;
  215.   GetExprX:=GetExpr(Integer(N));
  216.   end;
  217.  
  218. begin
  219. Sy := Nul;
  220. repeat
  221.   SkipSpaces;
  222.   Symname[0]:=#0;     {build up a phrase which may be needed later}
  223.   if BytePending then
  224.     begin
  225.     NValue:=PendingByte;
  226.     BytePending:=False;
  227.     Sy:=Bytesy;
  228.     end
  229.   else if UCh='(' then begin Sy:=Lparn; GetCh; end
  230.   else if UCh=')' then begin Sy:=Rparn; GetCh; end
  231.   else if UCh='/' then Error(Chi+2, 'Syntax')
  232.   else if GetExprX(NValue,C) then
  233.     begin
  234.     if C='<' then Sy:=Bytesy
  235.       else if C='>' then Sy:=Wordsy
  236.       else if NValue and $FF00 = 0 then Sy := Bytesy
  237.       else Sy:=Wordsy;
  238.     if UCh='/' then GetCh;
  239.     end
  240.   else
  241.     begin  {it's a symbolic phrase}
  242.     while (UCh<>'/') and (UCh<>')') do GetCh;  {finish reading the phrase}
  243.     if UCh='/' then
  244.       begin
  245.       GetCh;  {pass the '/' by}
  246.       Symname[0]:=Pred(Symname[0]); {but remove it from phrase}
  247.       end;
  248.     if (Pos('>',Symname)>0) or (Pos('*',Symname)>0) then
  249.       Sy:=Ident4
  250.     else if Pos('<',Symname)>0 then Sy:=Ident2
  251.     else Sy:=Identunk;    {unknown size}
  252.     end;
  253.   if Sy=Nul then GetCh;
  254. until Sy<>Nul;
  255. end;
  256.  
  257. {-------------GetByte}
  258. FUNCTION GetByte(Var P :Packet; PhraseOk : Boolean): Boolean;
  259. Var Result : Boolean;
  260. begin
  261. Result:=True;
  262. with P do
  263.   begin
  264.   Dispsize:=Bytesize;  Phrase:=False;
  265.   if (Sy=Ident2) or (Sy=Identunk) then
  266.     begin
  267.     if not PhraseOk then Result:=False
  268.     else
  269.       begin
  270.       Phrase:=True;
  271.       if Sy=Identunk then Insert('<',Symname,1);
  272.       S:=Symname;  {the phrase}
  273.       end;
  274.     end
  275.   else if Sy=Bytesy then Value:=Lo(NValue)
  276.   else if Sy=Wordsy then
  277.     begin
  278.     Value:=Lo(NValue);
  279.     BytePending:=True;
  280.     PendingByte:=Hi(NValue);
  281.     end
  282.   else Result:=False;
  283.   if Result then
  284.     begin
  285.     PC:=PC+1;
  286.     Next;
  287.     end;
  288.   GetByte:=Result;
  289.   end;
  290. end;
  291.  
  292. {-------------GetWord}
  293. PROCEDURE GetWord(Var P :Packet);
  294. Var H,L : Packet;
  295.   PROCEDURE WordErr;
  296.   begin Error(Chi,'Word or two bytes exp'); PC:=PC+2; Next; end;
  297. begin
  298. with P do
  299.   begin
  300.   Dispsize:=Wordsize; Phrase:=False;
  301.   if (Sy=Ident4) or (Sy=Identunk) then
  302.     begin
  303.     if Sy=Identunk then Insert('>',Symname,1);
  304.     Phrase:=True; S:=Symname;
  305.     PC:=PC+2;  Next;
  306.     end
  307.   else if Sy=Ident2 then WordErr
  308.   else if Sy=Wordsy then
  309.     begin Value:=NValue; PC:=PC+2;  Next; end
  310.   else if GetByte(L,not PhraseOk) then
  311.     begin
  312.     if not GetByte(H, not PhraseOk) then NumbyteErr;
  313.     Value:=H.Value Shl 8 +L.Value;
  314.     end
  315.   else WordErr;
  316.   end;
  317. end;
  318.